home *** CD-ROM | disk | FTP | other *** search
/ 130 MIDI Tool Box / 130 MIDI Tool Box.iso / sysex / sysex.pas < prev    next >
Pascal/Delphi Source File  |  1991-05-01  |  7KB  |  340 lines
  1. {
  2.   Author : Mike Cariotoglou, CIS 10012,1767
  3.   Date   : 01-May-1991
  4.   See SYSEX.DOC file for operation
  5. }
  6.  
  7.  
  8. program sysex;
  9.  
  10. uses crt,umpu;
  11.  
  12. const maxbuf    =50000;
  13.       sysexstart=$F0;
  14.       sysexend  =$F7;
  15.       txtext    ='.TXT';
  16.       binext    ='.SYX';
  17.  
  18. var fname1,fname2:string;
  19.     buffer:array[0..maxbuf-1] of byte;
  20.     Bp:word;
  21.     convert,manual:boolean;
  22.  
  23. procedure flushkbd;
  24.  begin
  25.   while keypressed do if readkey=#0 then if readkey=#0 then;
  26.  end;
  27.  
  28. procedure error(i:integer);
  29.  begin
  30.   flushkbd;
  31.   case i of
  32.    0:;
  33.    1:writeln('Input file not found');
  34.    2:writeln('File too large');
  35.    3:writeln('Format error, missing Start of Exclusive');
  36.    4:writeln('Too many data in');
  37.    5:writeln('Cannot create dest');
  38.    6:begin
  39.       writeln;
  40.       writeln('Syntax : SYSEX filename1 [filename2] /c|m');
  41.       writeln(' filename 1  : file to send');
  42.       writeln(' filename 2  : file to receive (optional)');
  43.       writeln(' options  /C : Convert file1 to file2 format');
  44.       writeln('          /M : Start dump manually');
  45.       writeln;
  46.       writeln('File names ending in .TXT are assumed SYSEX TXT format');
  47.       writeln('All others are assumed standard MIDIEX format');
  48.       writeln;
  49.       writeln('Ascii format metacommands : ');
  50.       writeln(' ''text''   : Insert characters in text format');
  51.       writeln(' ?Prompt  : Prompted input');
  52.       writeln(' |        : OR of next two bytes');
  53.       writeln(' @        : Begin checksum calculation');
  54.       writeln(' #        : Insert checksum');
  55.       writeln(' ;        : Rest of line is comment');
  56.      end;
  57.    else writeln('Error : ',i);
  58.   end;
  59.   send_command_to_mpu(mpu_reset);
  60.   halt
  61.  end;
  62.  
  63. function fixname(a:string):string;
  64.  begin
  65.   if pos('.',a)=0 then a:=a+binext;
  66.   fixname:=a;
  67.  end;
  68.  
  69. procedure getparms;
  70.  var i,j:integer;
  71.      a:string;
  72.  begin
  73.   if paramcount=0 then error(6);
  74.   fname1:='';
  75.   fname2:='';
  76.   convert:=false;
  77.   manual:=false;
  78.   for i:=1 to paramcount do
  79.    begin
  80.     a:=paramstr(i);
  81.     for j:=1 to length(a) do a[j]:=upcase(a[j]);
  82.     if a[1] in ['-','/'] then
  83.      begin
  84.       delete(a,1,1);
  85.       while a>'' do
  86.        begin
  87.         case upcase(a[1]) of
  88.          'C':convert:=true;
  89.          'M':manual:=true;
  90.          else error(6);
  91.         end;
  92.         delete(a,1,1)
  93.        end
  94.      end
  95.     else if fname1='' then fname1:=fixname(a) else fname2:=fixname(a);
  96.    end;
  97.   if (manual and (fname2>'')) or
  98.      (convert and (fname2='')) or
  99.      (manual and convert) then error(6);
  100.  end;
  101.  
  102. FUNCTION Hex(NUM,WIDTH:longint):STRing;
  103.  VAR I:INTEGER;
  104.      A:STRing;
  105.  BEGIN
  106.   A:='';
  107.   WHILE LENGTH(A)<WIDTH DO
  108.    BEGIN
  109.     I:=NUM and $f;
  110.     IF I>9 THEN I:=I+7;
  111.     A:=CHR(48+I)+A;
  112.     NUM:=NUM shr 4
  113.    END;
  114.   Hex:=A
  115.  END;
  116.  
  117. procedure readbuf(fname:string);
  118.  
  119.  var f1:file;
  120.      f2:text;
  121.      a,b:string;
  122.      i,j,expected,pp,sum:integer;
  123.      p:array[0..1] of integer;
  124.  
  125.  function getword(var a,b:string):boolean;
  126.   var i:integer;
  127.       delim:char;
  128.   begin
  129.    getword:=false;
  130.    while (a>'') and (a[1]=' ') do delete(a,1,1);
  131.    if a='' then exit;
  132.    if a[1]='''' then delim:='''' else delim:=' ';
  133.    i:=2;
  134.    while (i<=length(a)) and (a[i]<>delim) do inc(i);
  135.    b:=copy(a,1,i-1);
  136.    delete(a,1,i);
  137.    getword:=b>''
  138.   end;
  139.  
  140.  procedure add(b:byte);
  141.   begin
  142.    if expected=0 then
  143.     begin
  144.      if bp=maxbuf then error(2);
  145.      buffer[bp]:=b;
  146.      inc(bp);
  147.      sum:=(sum+b) and $7f
  148.     end
  149.    else
  150.     begin
  151.      p[pp]:=b;
  152.      inc(pp);
  153.      if pp=expected then
  154.       begin
  155.        expected:=0;
  156.        add(p[0] or p[1]);
  157.       end
  158.     end
  159.   end;
  160.  
  161.  begin {readbuf}
  162.   if pos(txtext,fname)=0 then
  163.    begin
  164.     assign(f1,fname); reset(f1,1); if ioresult<>0 then error(1);
  165.     Bp:=filesize(f1); if Bp>maxbuf then error(2);
  166.     blockread(f1,buffer,Bp);
  167.     close(F1);
  168.     exit
  169.    end;
  170.   assign(f2,fname); reset(f2); if ioresult<>0 then error(1);
  171.   bp:=0;
  172.   sum:=0;
  173.   expected:=0;
  174.   while not eof(f2) do
  175.    begin
  176.     readln(f2,a);
  177.     if a='' then exit;
  178.     while getword(a,b) do
  179.      case b[1] of
  180.       '''':for I:=2 to length(b) do add(ord(b[i]));
  181.       ';':a:=''; {comment}
  182.       '?':begin
  183.            delete(b,1,1);
  184.            write(b,' : '); readln(b);
  185.            val(b,i,j);
  186.            add(i)
  187.           end;
  188.       '|':begin
  189.            expected:=2;
  190.            pp:=0
  191.           end;
  192.       '@':sum:=0;
  193.       '#':add((-sum) and $7f);
  194.       else
  195.        begin
  196.         val('$'+b,i,j);
  197.         add(i)
  198.        end
  199.      end {case};
  200.    end {while not eof};
  201.   close(f2);
  202.  end;
  203.  
  204. procedure WriteBuf(fname:string);
  205.  var f1:file;
  206.      f2:text;
  207.      i,j:integer;
  208.  begin
  209.   if pos(txtext,fname)=0 then
  210.    begin
  211.     assign(f1,fname); rewrite(f1,1); if ioresult<>0 then error(5);
  212.     blockwrite(f1,buffer,Bp);
  213.     close(F1);
  214.     exit
  215.    end;
  216.   assign(f2,fname); rewrite(f2); if ioresult<>0 then error(5);
  217.   j:=0;
  218.   for i:=0 to bp-1 do
  219.    begin
  220.     if j=20 then
  221.      begin
  222.       writeln(f2);
  223.       j:=0
  224.      end;
  225.     write(f2,Hex(buffer[i],2),' ');
  226.     inc(j)
  227.    end;
  228.   writeln(f2);
  229.   close(f2)
  230.  end;
  231.  
  232. procedure sendbuf;
  233.  var i,count,block:word;
  234.      t:longint;
  235.      b:byte;
  236.  
  237.   procedure wait;
  238.    var t1:longint;
  239.    begin
  240.      {more to send, calculate delay,
  241.       calculate ticks this should have taken,
  242.       round up,add three for min delay of 110 ms  (trial & error value)
  243.       use 19 as approx of 18.2
  244.       actual formula is count*(time per byte) / time per tick}
  245.     t1:=t+(longint(count)*19+(3125 div 2)) div 3125+3;
  246.     while systemtick<t1 do;
  247.    end;
  248.  
  249.  begin
  250.   i:=0;
  251.   block:=0;
  252.   while i<Bp do
  253.    begin
  254.     if buffer[i]<>sysexstart then error(3);
  255.     t:=systemtick;
  256.     count:=0;
  257.     repeat
  258.      b:=buffer[i];
  259.      send_data_to_mpu(b);
  260.      inc(i);
  261.      inc(count);
  262.     until (i=Bp) or (b=sysexend);
  263.     inc(block);
  264.     writeln('Block : ',block,' Bytes : ',count);
  265.     if i<Bp then wait
  266.    end;
  267.  end;
  268.  
  269. procedure recbuf;
  270.  var b:byte;
  271.      pp:word;
  272.  
  273.  procedure add(b:byte);
  274.   begin
  275.    if Bp=maxbuf then error(4);
  276.    buffer[Bp]:=b;
  277.    inc(Bp)
  278.   end;
  279.  
  280.  begin {recbuf}
  281.   flushkbd;
  282.   writeln('Waiting for data, hit any key to stop');
  283.   repeat
  284.    if keypressed then error(0);
  285.   until get_data_from_mpu(b) and (b=sysexstart);
  286.   writeln('Receiving data, hit any key to stop');
  287.   Bp:=0;
  288.   add(b);
  289.   pp:=0;
  290.   repeat
  291.    if get_data_from_mpu(b) then if b<>$F8 then add(b) else
  292.    else if pp<>Bp then
  293.     begin
  294.      write(#13,Bp:6);
  295.      pp:=Bp
  296.     end
  297.   until keypressed;
  298.   flushkbd;
  299.  end;
  300.  
  301. begin {main}
  302.  clearmpuin;
  303.  getparms;
  304.  if manual then
  305.   begin
  306.    recbuf;
  307.    writebuf(fname1)
  308.   end
  309.  else if convert then
  310.   begin
  311.    readbuf(fname1);
  312.    writebuf(fname2);
  313.   end
  314.  else
  315.   begin
  316.    readbuf(fname1);
  317.    sendbuf;
  318.    if fname2>'' then
  319.     begin
  320.      recbuf;
  321.      writebuf(fname2)
  322.     end
  323.   end;
  324.  error(0);
  325. end.
  326.  
  327. notes:
  328. ------
  329.  
  330. txt input format:
  331.  
  332. xx 'ascii' | ?name  @ #
  333.  
  334. xx      = hex digits
  335. 'ascii' = ascii chars
  336. |       = OR of next two bytes
  337. ?name   = prompt for byte
  338. @       = begin chksum
  339. #       = put chksum
  340. ;       = test of line is comment